#!/usr/bin/perl -c

package MooseX::CLI::Command;

=head1 NAME

MooseX::CLI::Command - Dispatcher for CLI applications

=head1 SYNOPSIS

  use MyApp::CLI::Command;
  my $cmd = MyApp::CLI::Command->new_with_dispatch;
  $cmd->run;

  package MyApp::CLI::Command;
  use Any::Moose;
  with 'MooseX::CLI::Command';
  sub run {
      if (blessed $self eq __PACKAGE__) {
          # Subclass should override this method
          die "Command not recognized, try $0 help\n";
      };
  };

  package MyApp::CLI::Command::Help;
  use Any::Moose;
  extends 'MyApp::CLI::Command';
  with 'MooseX::CLI::Command::Help';

  package MyApp::CLI::Command::Me;
  use Any::Moose;
  extends 'MyApp::CLI::Command';
  sub run {
      print "Yes, it's me!\n";
  };
  # =head1 NAME and SYNOPSIS goes here

  $ myapp help me

=head1 DESCRIPTION

This class represents role of dispatcher for CLI applications.  The dispatcher
decodes command line arguments in C<@ARGV> array, loads the proper class,
creates an instance object and calls C<run> method.

The command line arguments allow to create an interface similar to C<git>,
C<svn>, C<svk> or C<ppm> applications.  The application provides a list of
commands (also with possible aliases).  The subcommands and per-command
options are also supported.  The additional options are handled by
L<MooseX::Getopt> role.

The base class for dispatcher is a class with name which implements
C<MooseX::CLI::Command> role and its name is ended with C<::Command> string.
If command argument was provided in C<@ARGV> array, the command name is
included to base class name and loaded if found.  Otherwise the last found
class or base class is used.

If the command class contains the L<perlpod> documentation then it is utilised
by C<show_help> and C<show_usage> methods.

This extension is compatible with L<Moose> and L<Mouse>.

=for readme stop

=cut

use 5.006;

use strict;
use warnings;

our $VERSION = '0.01';


# Debug if env is set
use if $ENV{PERL_DEBUG_MOOSEX_CLI_COMMAND}, 'Smart::Comments';

# Assertions
use Test::Assert ':assert';
use Exception::Assertion verbosity => 4;


use Any::Moose '::Role';


=head1 INHERITANCE

=over 2

=item *

with L<MooseX::Getopt::Basic> | L<MouseX::Getopt::Basic>

=back

=cut

with any_moose('X::Getopt::Basic');


=head1 REQUIRES

=over

=item run()

Runs commands via dispatched class.

=back

=cut

requires 'run';


use constant::boolean;

use File::Spec ();

use File::Basename ();
use Pod::Usage ();
use Pod::Escapes ();


=head1 EXCEPTIONS

=over

=item L<Exception::CLI>

Thrown whether a CLI application should be terminated with message error.

=back

=cut

use Exception::Base '+ignore_package' => [ __PACKAGE__, qr/^(Mo[ou]seX?|Class::MOP)(::|$)/ ];
use Exception::CLI;


# Base class for application commands
has _cmd_base_class => (
    is  => 'ro',
    isa => 'ClassName',
);


=head1 CONSTRUCTORS

=over

=item new_with_dispatch( args : Array )

This constructor parses C<@ARGV> array and sets C<ARGV> and C<extra_argv>
attributes as L<MooseX::Getopt> role does.  If C<@ARGV> array contains the
name of command or sub-command, then its class is loaded and proper arguments
are passed to its C<new> constructor.

=back

=cut

sub new_with_dispatch {
    my $class = shift;
    ### $class

    my %args  = @_;

    # Base cmd class ends with "::Command"
    my $cmd_base_class = $class;
    $cmd_base_class =~ s/^(.*?::Command)(::.*$|$)/$1/;

    my @new_extra_argv;
    CLASS: {
        # First, we need to get @extra_argv
        # and it requires Getopt::Long and MooseX::Getopt magic
        my %processed;
        {
            # Start new getopt session
            my $save = Getopt::Long::Configure('pass_through');

            # Call main routine.
            eval {
                local $SIG{__DIE__} = 'DEFAULT';
                %processed = $class->_parse_argv(
                    options => [
                        $class->_attrs_to_options(),
                    ],
                );
            };
            my $e = $@;

            # Restore saved settings.
            Getopt::Long::Configure($save);

            # Handle errors and return value.
            Exception::CLI->throw( message => $e ) if $e;
        };
        assert_not_null(%processed) if ASSERT;

        my @extra_argv = @{ $processed{argv} };
        ### @extra_argv

        # Second, we need to get $class based on @extra_argv

        # Try to add extra_argv to cmd_base_class and make new cmd_class
        my $cmd_class = $cmd_base_class;

        @new_extra_argv = @extra_argv;
        foreach my $arg (@extra_argv) {
            last unless $arg =~ /^[a-zA-Z]\w*/;

            my $try_cmd_class = $cmd_class . '::' . ucfirst( lc($arg) );
            ### $try_cmd_class

            last unless $class->_load_cmd_package($try_cmd_class);
            Moose->throw_error(
                "Command class ($try_cmd_class) must have implement "
              . __PACKAGE__ . " role"
            ) unless eval { $try_cmd_class->does(__PACKAGE__) };

            $cmd_class = $try_cmd_class;
            shift @new_extra_argv;
        };

        # Dispatch to another subclass
        if (length($cmd_class) gt length($class)) {
            $class = $cmd_class;
            redo CLASS;
        };
    };

    # If it is an alias then find its superclass
    $class = $class->_get_superclass_for_cmd_alias_package($class);
    ### $class

    # Third, we need to get @argv_copy and %params
    # and call MooseX::Getopt finally
    my (@argv_copy, %params);
    {
        # Parse for all arguments
        my %processed = eval {
            $class->_parse_argv(
                options => [
                    $class->_attrs_to_options(),
                ],
            );
        };
        ### %processed

        # Print usage message if getopt parser failed
        if ($@) {
            my $e = $@;

            # Recapture usage message
            eval { $class->show_usage };

            my $msg = "$e\n$@";
            Exception::CLI->throw( message => $msg );

            assert_false("Should die earlier") if ASSERT;
        };

        @argv_copy = @{ $processed{argv_copy} };
        %params = %{ $processed{params} };
    };

    # Last, we can dispatch to new class constructor
    return $class->new(
        ARGV       => \@argv_copy,
        extra_argv => \@new_extra_argv,
        %args,
        %params,
        _cmd_base_class => $cmd_base_class,
    );
};


=head1 METHODS

=over

=item show_help(I<>)

=item show_help( I<package> : ClassName )

Loads the I<package> or uses current class, parses its source file and throws
a L<Exception::CLI> with parsed help document as a message.

=cut

sub show_help {
    my $self = shift;
    my $package = shift || (blessed $self ? blessed $self : $self);

    my $filename = $INC{ $self->_get_filename_for_cmd_package( $package ) };
    ### $filename
    assert_true($filename) if ASSERT;

    my $buf = '';
    open my $fh, '>', \$buf
        or Moose->throw_error("Cannot open command class file: $!");
    Pod::Usage::pod2usage( {
        -input     => $filename,
        -output    => $fh,
        -verbose   => 2,
        -exitval   => 'NOEXIT',
        -noperldoc => 1,
    } );
    close $fh;

    my $base = $self->_cmd_base_class;
    assert_true($base) if ASSERT;

    # Print class name as command line arguments
    my $cmd_name = File::Basename::basename( $0 );
    $buf =~ m/(?:^|\n\s{4})\Q$base\E::([\w:]+)/;
    my $cmd_args = lc($1);
    $cmd_args =~ s/::/ /g;
    $buf =~ s/(^|\n\s{4})\Q$base\E::([\w:]+)/$1$cmd_name $cmd_args/g;
    $buf =~ s/(^|\n\s{4})\Q$base\E/$1$cmd_name/gs;

    # Remove formatting codes
    $buf =~ s{E<(.*)>}{Pod::Escapes::e2char($1)}ge;
    $buf =~ s/I(<[^>]*>)/$1/g;
    $buf =~ s/[A-HJ-Z]<([^>]*)>/$1/g;

    Exception::CLI->throw( message => $buf );
};


=item show_usage(I<>)

=item show_usage( I<package> : ClassName )

Loads the I<package> or uses current class, parses its source file and throws
a L<Exception::CLI> with parsed document as a message.

The usage message contains only SYNOPSIS section of parsed document.

=cut

sub show_usage {
    my $self = shift;
    my $package = blessed $self ? blessed $self : $self;

    my $filename = $INC{ $self->_get_cmd_package_filename( $package ) };
    ### $filename
    assert_true($filename) if ASSERT;

    my $buf = '';
    open my $fh, '>', \$buf
        or Moose->throw_error("Cannot open command class file: $!");
    Pod::Usage::pod2usage( {
        -input   => $filename,
        -output  => $fh,
        -verbose => 1,
        -exitval => 'NOEXIT',
    } );
    close $fh;

    # Remove formatting codes
    $buf =~ s{E<(.*)>}{Pod::Escapes::e2char($1)}ge;
    $buf =~ s/I(<[^>]*>)/$1/g;
    $buf =~ s/[A-HJ-Z]<([^>]*)>/$1/g;

    Exception::CLI->throw( message => $buf );
};


sub _load_cmd_package {
    my ($self, $package) = @_;

    my $filename = $self->_get_filename_for_cmd_package($package);
    ### $filename
    
    eval {
        require $filename;
    };
    if ($@) {
        return FALSE if $@ =~ /Can't locate \Q$filename\E in \@INC/;
        die;
    };

    return require $filename;
};


sub _get_filename_for_cmd_package {
    my ($self, $package) = @_;
    assert_not_null($package) if ASSERT;

    return File::Spec->catfile( split( /\::/, $package ) ) . '.pm';
};


sub _get_superclass_for_cmd_alias_package {
    my ($self, $package) = @_;
    assert_isa(any_moose('::Object'), $package) if ASSERT;

    while ($package->does('MooseX::CLI::Role::Alias')) {
        ### $package
        my @superclasses = $package->meta->superclasses;
        assert_true(@superclasses) if ASSERT;
        $package = $superclasses[0];
    };

    return $package;
};


sub _get_cmd_package_name {
    my ($self, @args) = @_;
};

1;


=begin umlwiki

= Class Diagram =

[                      <<role>>
                 MooseX::CLI::Command
 ----------------------------------------------------------
 -_cmd_base_class : ClassName
 ----------------------------------------------------------
 +run() <<requires>>
 +new_with_dispatch( args : Array ) <<constructor>>
 +show_help()
 +show_help( package : ClassName )
 +show_usage()
 +show_usage( package : ClassName )
 ----------------------------------------------------------]

[MooseX::CLI::Command] ---|> [MooseX::Getopt::Basic] | [MouseX::Getopt::Basic]

[MooseX::CLI::Command] ---> <<exception>> [Exception::CLI]

=end umlwiki

=head1 INTERNALS

C<MooseX::CLI::Command> uses L<MooseX::Getopt::Basic> role.  Unfortunately
it has limited API and then C<MooseX::CLI::Command> needs to call its private
methods to do the work.

C<Getopt::Long> has a worse and uglier API and unfortunately L<MooseX::Getopt>
doesn't allow to avoid this low-level module.  Sadly, L<MooseX::Getopt>
doesn't use L<Getopt::Long>'s OO interface and doesn't support additional
options for L<Getopt::Long>, so C<MooseX::Getopt::Basic> needs to use
C<L<Getopt::Long>::Configure()> function directly.

=head1 SEE ALSO

C<MooseX::CLI::Command> is similar to L<MooseX::App::Cmd> extension but is
somewhat different.  Mainly, it doesn't use L<Getopt::Long::Descriptive> and
it uses L<perlpod> documentation of command classes for generating help
messages.  Additionaly, C<MooseX::CLI::Command> scans all C<@INC> directories
to find command classes and supports command aliases.

This extension is more inspired by L<App::CLI>.

See also:

L<MooseX::Getopt>, L<Getopt::Long>, L<MooseX::App::Cmd>.

More specialized roles for C<MooseX::CLI::Command>:

L<MooseX::CLI::Command::Help>, L<MooseX::CLI::Command::Help::Commands>,
L<MooseX::CLI::Role::Alias>, L<MooseX::CLI::Option::Help>,
L<MooseX::CLI::Option::Usage>.

=head1 AUTHOR

Piotr Roszatycki <dexter@cpan.org>

=head1 COPYRIGHT

Copyright (C) 2009 by Piotr Roszatycki <dexter@cpan.org>.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

See L<http://www.perl.com/perl/misc/Artistic.html>
